home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tcl7.4 / tests / uplevel.test < prev    next >
Encoding:
Text File  |  1994-12-18  |  2.7 KB  |  110 lines
  1. # Commands covered:  uplevel
  2. #
  3. # This file contains a collection of tests for one or more of the Tcl
  4. # built-in commands.  Sourcing this file into Tcl runs the tests and
  5. # generates output for errors.  No output means no errors were found.
  6. #
  7. # Copyright (c) 1991-1993 The Regents of the University of California.
  8. # Copyright (c) 1994 Sun Microsystems, Inc.
  9. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12. #
  13. # @(#) uplevel.test 1.12 94/12/17 16:20:31
  14.  
  15. if {[string compare test [info procs test]] == 1} then {source defs}
  16.  
  17. proc a {x y} {
  18.     newset z [expr $x+$y]
  19.     return $z
  20. }
  21. proc newset {name value} {
  22.     uplevel set $name $value
  23.     uplevel 1 {uplevel 1 {set xyz 22}}
  24. }
  25.  
  26. test uplevel-1.1 {simple operation} {
  27.     set xyz 0
  28.     a 22 33
  29. } 55
  30. test uplevel-1.2 {command is another uplevel command} {
  31.     set xyz 0
  32.     a 22 33
  33.     set xyz
  34. } 22
  35.  
  36. proc a1 {} {
  37.     b1
  38.     global a a1
  39.     set a $x
  40.     set a1 $y
  41. }
  42. proc b1 {} {
  43.     c1
  44.     global b b1
  45.     set b $x
  46.     set b1 $y
  47. }
  48. proc c1 {} {
  49.     uplevel 1 set x 111
  50.     uplevel #2 set y 222
  51.     uplevel 2 set x 333
  52.     uplevel #1 set y 444
  53.     uplevel 3 set x 555
  54.     uplevel #0 set y 666
  55. }
  56. a1
  57. test uplevel-2.1 {relative and absolute uplevel} {set a} 333
  58. test uplevel-2.2 {relative and absolute uplevel} {set a1} 444
  59. test uplevel-2.3 {relative and absolute uplevel} {set b} 111
  60. test uplevel-2.4 {relative and absolute uplevel} {set b1} 222
  61. test uplevel-2.5 {relative and absolute uplevel} {set x} 555
  62. test uplevel-2.6 {relative and absolute uplevel} {set y} 666
  63.  
  64. test uplevel-3.1 {uplevel to same level} {
  65.     set x 33
  66.     uplevel #0 set x 44
  67.     set x
  68. } 44
  69. test uplevel-3.2 {uplevel to same level} {
  70.     set x 33
  71.     uplevel 0 set x
  72. } 33
  73. test uplevel-3.3 {uplevel to same level} {
  74.     set y xxx
  75.     proc a1 {} {set y 55; uplevel 0 set y 66; return $y}
  76.     a1
  77. } 66
  78. test uplevel-3.4 {uplevel to same level} {
  79.     set y zzz
  80.     proc a1 {} {set y 55; uplevel #1 set y}
  81.     a1
  82. } 55
  83.  
  84. test uplevel-4.1 {error: non-existent level} {
  85.     list [catch c1 msg] $msg
  86. } {1 {bad level "#2"}}
  87. test uplevel-4.2 {error: non-existent level} {
  88.     proc c2 {} {uplevel 3 {set a b}}
  89.     list [catch c2 msg] $msg
  90. } {1 {bad level "3"}}
  91. test uplevel-4.3 {error: not enough args} {
  92.     list [catch uplevel msg] $msg
  93. } {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}
  94. test uplevel-4.4 {error: not enough args} {
  95.     proc upBug {} {uplevel 1}
  96.     list [catch upBug msg] $msg
  97. } {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}
  98.  
  99. proc a2 {} {
  100.     uplevel a3
  101. }
  102. proc a3 {} {
  103.     global x y
  104.     set x [info level]
  105.     set y [info level 1]
  106. }
  107. a2
  108. test uplevel-5.1 {info level} {set x} 1
  109. test uplevel-5.2 {info level} {set y} a3
  110.